home *** CD-ROM | disk | FTP | other *** search
/ PC Answers 1995 May / PC Answers CD-ROM 7 (Future Publishing) (May 1995).iso / vbits / code / morris / aboutbox.bas next >
Encoding:
BASIC Source File  |  1994-11-15  |  35.2 KB  |  1,336 lines
  1. '==========================================================
  2. '
  3. '    Module - ABOUTBOX.BAS
  4. '
  5. '    Module Prefix -
  6. '
  7. '    Author - Peter J. Morris. TMS Ltd.
  8. '
  9. '    Date Written : #### Date - 16/11/94    Time - 03:11
  10. '
  11. '    Purpose -
  12. '    Support module for TMS About box. TMS bods. Note that this is cut down version
  13. '    of TMS Tools code (which was written in C') and  is for demonstration purposes
  14. '    only.
  15. '    The 'C' source for the DLL is NOT normally to be distributed with this demo.
  16. '
  17. '    TMS dudes/dudettes - this code may not be used without error handlers.
  18. '
  19. '    Revisions
  20. '    BY            WHY            AFFECTED
  21. '    Peter J. Morris. TMS Ltd. Original code.
  22. '
  23. '==========================================================
  24.  
  25.  
  26. Option Explicit
  27.  
  28.  
  29. ' General dogs body variable.
  30. Global g_vDummy As Variant
  31.  
  32. ' Hold resource information about application.  This could be  loaded  into these strings
  33. ' by making calls to an API in the Init() routine  in this module.  The information would
  34. ' have to be appended using some sort of resource editor as the current version of Visual
  35. ' Basic doesn't use  resources directly.  The information would normally be written there
  36. ' by a setup program of course.
  37.  
  38. Dim g_sAppName     As String      ' The name given to the application.
  39. Dim g_sVersion     As String      ' The name given to the version.
  40. Dim g_sCopyright   As String      ' The application's copy right information.
  41. Dim g_sProductID   As String      ' The product ID.
  42.  
  43. ' STRINGTABLE ID constants - these could be used with an attached stringtable
  44. ' if you can add one using your own tools etc.
  45. Global Const g_nAppName = 1
  46. Global Const g_nVersion = 2
  47. Global Const g_nCopyright = 3
  48. Global Const g_nProductID = 4
  49.  
  50. ' Used with Format$
  51. Global Const g_sYesNo = "Yes/No"
  52. Global Const g_sThousands = "#,##0"
  53.  
  54. ' GetSystemMetrics() constants.
  55. Global Const SM_DEBUG = 22
  56. Global Const SM_SWAPBUTTON = 23
  57.  
  58.  
  59. ' Handy constant used for getting our processe's instance handle from any window
  60. ' in the project.
  61. Global Const GWW_HINSTANCE = (-6)
  62.     
  63. ' Used by GetWinFlags().
  64. Global Const WF_CPU086 = &H40
  65. Global Const WF_CPU186 = &H80
  66. Global Const WF_CPU286 = &H2
  67. Global Const WF_CPU386 = &H4
  68. Global Const WF_CPU486 = &H8
  69. Global Const WF_8087 = &H400
  70. Global Const WF_PMODE = &H1
  71. Global Const WF_STANDARD = &H10
  72. Global Const WF_ENHANCED = &H20
  73. Global Const WF_LARGEFRAME = &H100
  74. Global Const WF_SMALLFRAME = &H200
  75. Global Const WF_PAGING = &H800
  76.     
  77.  
  78.  
  79. ' ================== REAL TMS stuff =====================
  80.  
  81. ' TMS DLL entry point  in  ABOUTDLL.DLL  library.  Note that instead of using 'As Any' here that
  82. ' you could use the 'Alias' feature in Visual Basic to make each call to bAboutCall 'type safe'.
  83. Declare Function bAboutCall Lib "ABOUTDLL.DLL" (ByVal nServiceID As Integer, lpStruct As Any) As Integer
  84.  
  85. ' Mouse Info type.
  86. Const ID_MOUSE = 1
  87. Type VBMOUSEINFO
  88.     nSize                       As Integer      ' Size of this structure - same for all passed TMS structures.
  89.     bMouseExists                As Integer      ' VB True if the mouse exists else false.
  90.     nNumMouseButtons            As Integer      ' The number of mouse buttons on the mouse.
  91.     nMouseCommPort              As Integer      ' The com port the mouse is connected to.
  92. End Type
  93.  
  94. ' Registration info type.
  95. Const ID_USER = 2
  96.  Type VBUSERINFO
  97.     nSize                       As Integer
  98.     sName                       As String * 255 ' Registered user's name.
  99.     sOrg                        As String * 255 ' Their company/organisation.
  100. End Type
  101.  
  102. ' Keyboard info type.
  103. Const ID_KYBD = 3
  104.  Type VBKYBDINFO
  105.     nSize                       As Integer
  106.     nType                       As Integer      ' Type of keyboard - 101 key etc.
  107.     nCodePage                   As Integer      ' Currently used code page, 437 etc.
  108. End Type
  109.  
  110. ' Physical memory type.
  111. Const ID_PHYSMEM = 4
  112.  Type VBPHYMEMINFO
  113.     nSize                       As Integer
  114.     nBase                       As Integer      ' Base memory (640 Kb etc).
  115.     nEXMS                       As Integer      ' Extended memory.
  116. End Type
  117.  
  118. ' Versioning type.
  119. Const ID_VERSION = 5
  120.  Type VBVERINFO
  121.     nSize                       As Integer
  122.     nDOSMin                     As Integer      ' DOS min version.
  123.     nDOSMax                     As Integer      ' DOS max version.
  124.     nVBVer                      As Integer      ' VB version.
  125.     sWinVer                     As String * 10  ' Windows version.
  126. End Type
  127.  
  128. ' Disk type.
  129. Const ID_DISK = 6
  130.  Type VBDISKINFO
  131.     nSize                       As Integer
  132.     bShareInstalled             As Integer      ' VB True if a 'share' is installed else false.
  133.     lTotal                      As Long         ' Total disk space.
  134.     lFree                       As Long         ' Free disk space.
  135.     nDriveNo                    As Integer      ' Drive number, 0 = default (usually 'C:').
  136. End Type
  137.  
  138. ' Global heap type.
  139. Const ID_GLOBAL = 7
  140.  Type VBGLOBALINFO
  141.     nSize                       As Integer
  142.     lLargestFree                As Long         ' Largest free-block in heap.
  143.     lTotalSize                  As Long         ' total size of all segments in heap.
  144. End Type
  145.  
  146. ' Linear memory type.
  147. Const ID_LINMEM = 8
  148.  Type VBLINMEMINFO
  149.     nSize                       As Integer
  150.     lMaxLockPages               As Long         ' All obvious.
  151.     lFreeMemory                 As Long
  152.     lLargestFreeBlock           As Long
  153.     lFreeLinearSpace            As Long
  154.     lTotalMemory                As Long
  155.     lSwapPages                  As Long
  156.     lTotalLinearSpace           As Long
  157. End Type
  158.  
  159. ' Used by (and defined by) TOOLHELP for SystemHeapInfo() function.
  160.  Type SYSHEAPINFO
  161.     lSize                       As Long
  162.     nUserFreePercent            As Integer
  163.     nGDIFreePercent             As Integer
  164.     nDummy1                     As Integer
  165.     nDummy2                     As Integer
  166. End Type
  167.  
  168.  
  169. ' Standard API functions used by this application.
  170. Declare Function DrawIcon Lib "USER" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal hIcon As Integer) As Integer
  171. Declare Function ExtractIcon Lib "Shell" (ByVal hInst As Integer, ByVal lpFileName As String, ByVal nIconID As Integer) As Integer
  172. Declare Function GetFreeSpace Lib "Kernel" (ByVal nFlags As Integer) As Long
  173. Declare Function GetModuleFileName Lib "Kernel" (ByVal hInst As Integer, ByVal lpFileName As String, ByVal nSize As Integer) As Integer
  174. Declare Function GetModuleHandle Lib "Kernel" (ByVal lpModuleName As String) As Integer
  175. Declare Function GetSystemDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
  176. Declare Function GetSystemMetrics Lib "USER" (ByVal nIndex As Integer) As Integer
  177. Declare Function GetWindowsDirectory Lib "Kernel" (ByVal lpBuffer As String, ByVal nSize As Integer) As Integer
  178. Declare Function GetWinFlags Lib "Kernel" () As Long
  179. Declare Function GetWindowWord Lib "USER" (ByVal hWnd As Integer, ByVal nIndex As Integer) As Integer
  180. Declare Function SystemHeapInfo Lib "TOOLHELP.DLL" (shi As SYSHEAPINFO) As Integer
  181. Declare Function WinHelp Lib "USER" (ByVal hWnd As Integer, ByVal lpHelpFile As String, ByVal wCommand As Integer, ByVal dwData As Long) As Integer
  182.  
  183. '==========================================================
  184. '
  185. '    Function - DoCaption
  186. '
  187. '    Author - Peter J. Morris. TMS Ltd.
  188. '
  189. '    Date Written: #### Date - 16/11/94    Time - 03:11
  190. '
  191. '    Purpose - See function purpose.
  192. '
  193. '    Revisions:
  194. '    BY            WHY            AFFECTED
  195. '    Peter J. Morris. TMS Ltd. Original code.
  196. '
  197. '
  198. '    INPUTS -  frm -> Form to use.
  199. '
  200. '
  201. '    OUTPUTS - None
  202. '
  203. '==========================================================
  204. Sub DoCaption (frm As Form)
  205. '==========================================================
  206. '
  207. '    Form: ABOUTBOX.BAS Procedure: DoCaption
  208. '
  209. '    Author - Peter J. Morris. TMS Ltd.
  210. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  211. '
  212. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  213. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  214. '
  215. '    Purpose/Description In brief:
  216. '    Sub that updates current (frm) caption, and the label controls
  217. '    lblCaption and lblProductID.
  218. '
  219. '=========================================================
  220.  
  221. ' Set up general error handler
  222.  
  223. On Error GoTo Error_DoCaption:
  224.  
  225.     ' ========== Code Starts.==========
  226.     
  227.  
  228.     Dim sAppName As String
  229.  
  230.     ' Get App name.
  231.     sAppName = App.EXEName
  232.         
  233.     ' Lower case it.
  234.     sAppName = LCase$(sAppName)
  235.     
  236.     ' Remake it by using all of the name (in lower case) plus the first
  237.     ' character of it in upper case.
  238.     sAppName = UCase$(Left$(sAppName, 1)) & Mid$(sAppName, 2)
  239.  
  240.     frm!lblCaption.Caption = g_sAppName & " (" & sAppName & ")" & " " & g_sVersion & Chr$(10) & g_sCopyright
  241.     
  242.     frm.Caption = "About " & g_sAppName
  243.  
  244.     frm!lblProductID.Caption = g_sProductID
  245.  
  246.  
  247.     ' ========== Code Ends  .==========
  248.  
  249.     Exit Sub
  250.  
  251. ' Error handler
  252. Error_DoCaption:
  253.  
  254.     ' Call general error handler
  255.  
  256.     ErrorHandler "ABOUTBOX.BAS/DoCaption", Err, Error$
  257.  
  258.     ' Default resume behaviour: exit this sub/func
  259.  
  260.     Resume Exit_DoCaption:
  261.  
  262. Exit_DoCaption:
  263.  
  264.  
  265. End Sub
  266.  
  267. '==========================================================
  268. '
  269. '    Function - DoDirs
  270. '
  271. '    Author - Peter J. Morris. TMS Ltd.
  272. '
  273. '    Date Written: #### Date - 16/11/94    Time - 03:11
  274. '
  275. '    Purpose - See function purpose.
  276. '
  277. '    Revisions:
  278. '    BY            WHY            AFFECTED
  279. '    Peter J. Morris. TMS Ltd. Original code.
  280. '
  281. '
  282. '    INPUTS -  frm -> Form to use.
  283. '
  284. '
  285. '    OUTPUTS - None
  286. '
  287. '==========================================================
  288. Sub DoDirs (frm As Form)
  289. '==========================================================
  290. '
  291. '    Form: ABOUTBOX.BAS Procedure: DoDirs
  292. '
  293. '    Author - Peter J. Morris. TMS Ltd.
  294. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  295. '
  296. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  297. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  298. '
  299. '    Purpose/Description In brief:
  300. '    Sub to do 'directories' stuff.
  301. '
  302. '=========================================================
  303.  
  304. ' Set up general error handler
  305.  
  306. On Error GoTo Error_DoDirs:
  307.  
  308.     ' ========== Code Starts.==========
  309.     
  310.     
  311.     Dim sWinDir     As String
  312.     Dim sSysDir     As String
  313.     Dim sModDir     As String
  314.     Dim sTmpDir     As String
  315.  
  316.     ' Bit of padding.
  317.     sWinDir = String$(255, 0)
  318.     sSysDir = String$(255, 0)
  319.  
  320.     ' Get Windows and System directory.
  321.     sWinDir = Left$(sWinDir, GetWindowsDirectory(sWinDir, Len(sWinDir)))
  322.     sSysDir = Left$(sSysDir, GetSystemDirectory(sSysDir, Len(sSysDir)))
  323.     
  324.     ' TEMP dir is got from environment variable.
  325.     sTmpDir = Environ$("TEMP")
  326.     If Len(sTmpDir) = 0 Then sTmpDir = "None"
  327.     
  328.     ' Set labels. sCheckCaption() ensures that the text fits into the label control as
  329.     ' it's easy for paths to be long man!
  330.     frm!lblWinDir.Caption = sCheckCaption(frm, frm.lblWinDir, sWinDir)
  331.     frm!lblSysDir.Caption = sCheckCaption(frm, frm.lblSysDir, sSysDir)
  332.     frm!lblModDir.Caption = sCheckCaption(frm, frm.lblModDir, App.Path)
  333.     frm!lblTEMPDir.Caption = sCheckCaption(frm, frm.lblTEMPDir, sTmpDir)
  334.  
  335.  
  336.     ' ========== Code Ends  .==========
  337.  
  338.     Exit Sub
  339.  
  340. ' Error handler
  341. Error_DoDirs:
  342.  
  343.     ' Call general error handler
  344.  
  345.     ErrorHandler "ABOUTBOX.BAS/DoDirs", Err, Error$
  346.  
  347.     ' Default resume behaviour: exit this sub/func
  348.  
  349.     Resume Exit_DoDirs:
  350.  
  351. Exit_DoDirs:
  352.  
  353.  
  354. End Sub
  355.  
  356. '==========================================================
  357. '
  358. '    Function - DoDisk
  359. '
  360. '    Author - Peter J. Morris. TMS Ltd.
  361. '
  362. '    Date Written: #### Date - 16/11/94    Time - 03:11
  363. '
  364. '    Purpose - See function purpose.
  365. '
  366. '    Revisions:
  367. '    BY            WHY            AFFECTED
  368. '    Peter J. Morris. TMS Ltd. Original code.
  369. '
  370. '
  371. '    INPUTS -  frm -> Form to use.
  372. '
  373. '
  374. '    OUTPUTS - None
  375. '
  376. '==========================================================
  377. Sub DoDisk (frm As Form)
  378. '==========================================================
  379. '
  380. '    Form: ABOUTBOX.BAS Procedure: DoDisk
  381. '
  382. '    Author - Peter J. Morris. TMS Ltd.
  383. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  384. '
  385. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  386. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  387. '
  388. '    Purpose/Description In brief:
  389. '    Sub to do disk (default) stuff.
  390. '
  391. '=========================================================
  392.  
  393. ' Set up general error handler
  394.  
  395. On Error GoTo Error_DoDisk:
  396.  
  397.     ' ========== Code Starts.==========
  398.  
  399.  
  400.     ' Call TMS DLL for disk information. DLL functions take integer
  401.     ' argument which specifies drive to examine.
  402.     Dim di As VBDISKINFO
  403.     
  404.     di.nSize = Len(di)
  405.     
  406.     di.nDriveNo = 0
  407.     
  408.     If bAboutCall(ID_DISK, di) <> False Then
  409.     
  410.         frm!lblDiskTotalSpace.Caption = Format$(di.lTotal, g_sThousands) & " Bytes"
  411.         frm!lblDiskFreeSpace.Caption = Format$(di.lFree, g_sThousands) & " Bytes"
  412.         frm!lblShareLoaded.Caption = Format$(di.bShareInstalled, g_sYesNo)
  413.         
  414.     Else
  415.         If nProcessDLLError() = True Then End
  416.     End If
  417.     
  418.  
  419.     ' ========== Code Ends  .==========
  420.  
  421.     Exit Sub
  422.  
  423. ' Error handler
  424. Error_DoDisk:
  425.  
  426.     ' Call general error handler
  427.  
  428.     ErrorHandler "ABOUTBOX.BAS/DoDisk", Err, Error$
  429.  
  430.     ' Default resume behaviour: exit this sub/func
  431.  
  432.     Resume Exit_DoDisk:
  433.  
  434. Exit_DoDisk:
  435.  
  436.  
  437. End Sub
  438.  
  439. '==========================================================
  440. '
  441. '    Function - DoKB
  442. '
  443. '    Author - Peter J. Morris. TMS Ltd.
  444. '
  445. '    Date Written: #### Date - 16/11/94    Time - 03:11
  446. '
  447. '    Purpose - See function purpose.
  448. '
  449. '    Revisions:
  450. '    BY            WHY            AFFECTED
  451. '    Peter J. Morris. TMS Ltd. Original code.
  452. '
  453. '
  454. '    INPUTS -  frm -> Form to use.
  455. '
  456. '
  457. '    OUTPUTS - None
  458. '
  459. '==========================================================
  460. Sub DoKB (frm As Form)
  461. '==========================================================
  462. '
  463. '    Form: ABOUTBOX.BAS Procedure: DoKB
  464. '
  465. '    Author - Peter J. Morris. TMS Ltd.
  466. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  467. '
  468. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  469. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  470. '
  471. '    Purpose/Description In brief:
  472. '    Sub to do keyboard stuff.
  473. '
  474. '=========================================================
  475.  
  476. ' Set up general error handler
  477.  
  478. On Error GoTo Error_DoKB:
  479.  
  480.     ' ========== Code Starts.==========
  481.  
  482.  
  483.     Dim ki          As VBKYBDINFO
  484.     Dim sType       As String
  485.     Dim sCodePage   As String
  486.     
  487.     ki.nSize = Len(ki)
  488.     
  489.     If bAboutCall(ID_KYBD, ki) <> False Then
  490.  
  491.         ' Select type string from type ID.
  492.         Select Case ki.nType
  493.             Case 1
  494.                 sType = "IBM PC, XT or compatible (83 key)"
  495.             Case 2
  496.                 sType = "Olivetti M24 ICO (102 key)"
  497.             Case 3
  498.                 sType = "IBM AT (84 keys) or similar"
  499.             Case 4
  500.                 sType = "IBM Enhanced (101 or 102 keys)"
  501.             Case 5
  502.                 sType = "Nokia 1050"
  503.             Case 6
  504.                 sType = "Nokia"
  505.             Case Else
  506.                 sType = "No information"
  507.         End Select
  508.     
  509.         ' Select code page string from CP ID.
  510.         Select Case ki.nCodePage
  511.             Case 437
  512.                 sCodePage = "Default (U.S. and most countries)"
  513.             Case 860
  514.                 sCodePage = "Portugal"
  515.             Case 863
  516.                 sCodePage = "French Canada"
  517.             Case 865
  518.                 sCodePage = "Norway/Denmark"
  519.             Case 850
  520.                 sCodePage = "International"
  521.             Case Else
  522.                 sCodePage = "No information"
  523.         End Select
  524.     
  525.         ' Set labels.
  526.         frm!lblKBType.Caption = sType
  527.         frm!lblActiveCP.Caption = sCodePage
  528.  
  529.     Else
  530.         If nProcessDLLError() = True Then End
  531.     End If
  532.  
  533.  
  534.     ' ========== Code Ends  .==========
  535.  
  536.     Exit Sub
  537.  
  538. ' Error handler
  539. Error_DoKB:
  540.  
  541.     ' Call general error handler
  542.  
  543.     ErrorHandler "ABOUTBOX.BAS/DoKB", Err, Error$
  544.  
  545.     ' Default resume behaviour: exit this sub/func
  546.  
  547.     Resume Exit_DoKB:
  548.  
  549. Exit_DoKB:
  550.  
  551.  
  552. End Sub
  553.  
  554. '==========================================================
  555. '
  556. '    Function - DoMem
  557. '
  558. '    Author - Peter J. Morris. TMS Ltd.
  559. '
  560. '    Date Written: #### Date - 16/11/94    Time - 03:11
  561. '
  562. '    Purpose - See function purpose.
  563. '
  564. '    Revisions:
  565. '    BY            WHY            AFFECTED
  566. '    Peter J. Morris. TMS Ltd. Original code.
  567. '
  568. '
  569. '    INPUTS -  frm -> Form to use.
  570. '
  571. '
  572. '    OUTPUTS - None
  573. '
  574. '==========================================================
  575. Sub DoMem (frm As Form)
  576. '==========================================================
  577. '
  578. '    Form: ABOUTBOX.BAS Procedure: DoMem
  579. '
  580. '    Author - Peter J. Morris. TMS Ltd.
  581. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  582. '
  583. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  584. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  585. '
  586. '    Purpose/Description In brief:
  587. '    Sub to do memory stuff (excluding local heap stuff).
  588. '
  589. '=========================================================
  590.  
  591. ' Set up general error handler
  592.  
  593. On Error GoTo Error_DoMem:
  594.  
  595.     ' ========== Code Starts.==========
  596.  
  597.  
  598.     Dim pmi As VBPHYMEMINFO
  599.     
  600.     pmi.nSize = Len(pmi)
  601.     
  602.     ' Do base and extended memory.
  603.     If bAboutCall(ID_PHYSMEM, pmi) <> False Then
  604.         
  605.         frm!lblBaseMem.Caption = Format$(pmi.nBase, g_sThousands) & " KB"
  606.         frm!lblExtMem.Caption = Format$(pmi.nEXMS, g_sThousands) & " KB"
  607.     
  608.     Else
  609.         If nProcessDLLError() = True Then End
  610.     End If
  611.  
  612.     Dim lmi As VBLINMEMINFO
  613.     
  614.     lmi.nSize = Len(lmi)
  615.  
  616.     ' Do linear (memory manager information) memory.
  617.     If bAboutCall(ID_LINMEM, lmi) <> False Then
  618.  
  619.         frm!lblMaxLocablePages.Caption = Format$(lmi.lMaxLockPages, g_sThousands) & " KB"
  620.         frm!lblFreeMemory.Caption = Format$(lmi.lFreeMemory, g_sThousands) & " KB"
  621.         frm!lblLargestFreeBlock1.Caption = Format$(lmi.lLargestFreeBlock, g_sThousands) & " KB"
  622.         frm!lblFreeLinearMemory.Caption = Format$(lmi.lFreeLinearSpace, g_sThousands) & " KB"
  623.         frm!lblTotalMemory.Caption = Format$(lmi.lTotalMemory, g_sThousands) & " KB"
  624.         frm!lblSwapFilePages.Caption = Format$(lmi.lSwapPages, g_sThousands) & " KB"
  625.         frm!lblTotalLinearSpace.Caption = Format$(lmi.lTotalLinearSpace, g_sThousands) & " KB"
  626.  
  627.     Else
  628.         If nProcessDLLError() = True Then End
  629.     End If
  630.  
  631.     Dim gi As VBGLOBALINFO
  632.     
  633.     gi.nSize = Len(gi)
  634.     
  635.     ' Do global heap memory.
  636.     If bAboutCall(ID_GLOBAL, gi) <> False Then
  637.         
  638.         frm!lblLargestFreeBlock.Caption = Format$(gi.lLargestFree, g_sThousands) & " KB"
  639.         frm!lblGlobalHeapTotal.Caption = Format$(gi.lTotalSize, g_sThousands) & " KB"
  640.  
  641.     Else
  642.         If nProcessDLLError() = True Then End
  643.     End If
  644.  
  645.  
  646.     ' ========== Code Ends  .==========
  647.  
  648.     Exit Sub
  649.  
  650. ' Error handler
  651. Error_DoMem:
  652.  
  653.     ' Call general error handler
  654.  
  655.     ErrorHandler "ABOUTBOX.BAS/DoMem", Err, Error$
  656.  
  657.     ' Default resume behaviour: exit this sub/func
  658.  
  659.     Resume Exit_DoMem:
  660.  
  661. Exit_DoMem:
  662.  
  663.  
  664. End Sub
  665.  
  666. Sub DoMisc (frm As Form)
  667. '// Sub to do misc stuff.
  668.     ' Update debugging kernel status caption.
  669.     frm!lblDKL.Caption = Format$(GetSystemMetrics(SM_DEBUG), g_sYesNo)
  670.  
  671. End Sub
  672.  
  673. '==========================================================
  674. '
  675. '    Function - DoMouse
  676. '
  677. '    Author - Peter J. Morris. TMS Ltd.
  678. '
  679. '    Date Written: #### Date - 16/11/94    Time - 03:11
  680. '
  681. '    Purpose - See function purpose.
  682. '
  683. '    Revisions:
  684. '    BY            WHY            AFFECTED
  685. '    Peter J. Morris. TMS Ltd. Original code.
  686. '
  687. '
  688. '    INPUTS -  frm -> Form to use.
  689. '
  690. '
  691. '    OUTPUTS - None
  692. '
  693. '==========================================================
  694. Sub DoMouse (frm As Form)
  695. '==========================================================
  696. '
  697. '    Form: ABOUTBOX.BAS Procedure: DoMouse
  698. '
  699. '    Author - Peter J. Morris. TMS Ltd.
  700. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  701. '
  702. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  703. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  704. '
  705. '    Purpose/Description In brief:
  706. '    Sub to do mouse stuff.
  707. '
  708. '=========================================================
  709.  
  710. ' Set up general error handler
  711.  
  712. On Error GoTo Error_DoMouse:
  713.  
  714.     ' ========== Code Starts.==========
  715.  
  716.  
  717.     ' Defined by TMS DLL.
  718.     Dim mi As VBMOUSEINFO
  719.  
  720.     ' Init structure as required by TMS DLL.
  721.     mi.nSize = Len(mi)
  722.  
  723.     ' Call TMS DLL.
  724.     If bAboutCall(ID_MOUSE, mi) <> False Then
  725.     
  726.         frm!lblMPresent.Caption = Format$(mi.bMouseExists, g_sYesNo)
  727.         frm!lblMButtons.Caption = CStr(mi.nNumMouseButtons)
  728.         frm!lblMPort.Caption = IIf(mi.nMouseCommPort <> 0, CStr(mi.nMouseCommPort), "Bus Mouse")
  729.     
  730.         ' Determine whether or not Left and Right are logically reversed.
  731.         frm!lblButtonsReversed.Caption = Format$(GetSystemMetrics(SM_SWAPBUTTON), g_sYesNo)
  732.     Else
  733.         If nProcessDLLError() = True Then End
  734.     End If
  735.     
  736.  
  737.     ' ========== Code Ends  .==========
  738.  
  739.     Exit Sub
  740.  
  741. ' Error handler
  742. Error_DoMouse:
  743.  
  744.     ' Call general error handler
  745.  
  746.     ErrorHandler "ABOUTBOX.BAS/DoMouse", Err, Error$
  747.  
  748.     ' Default resume behaviour: exit this sub/func
  749.  
  750.     Resume Exit_DoMouse:
  751.  
  752. Exit_DoMouse:
  753.  
  754.  
  755. End Sub
  756.  
  757. '==========================================================
  758. '
  759. '    Function - DoRegInfo
  760. '
  761. '    Author - Peter J. Morris. TMS Ltd.
  762. '
  763. '    Date Written: #### Date - 16/11/94    Time - 03:11
  764. '
  765. '    Purpose - See function purpose.
  766. '
  767. '    Revisions:
  768. '    BY            WHY            AFFECTED
  769. '    Peter J. Morris. TMS Ltd. Original code.
  770. '
  771. '
  772. '    INPUTS -  frm -> Form to use.
  773. '
  774. '
  775. '    OUTPUTS - None
  776. '
  777. '==========================================================
  778. Sub DoRegInfo (frm As Form)
  779. '==========================================================
  780. '
  781. '    Form: ABOUTBOX.BAS Procedure: DoRegInfo
  782. '
  783. '    Author - Peter J. Morris. TMS Ltd.
  784. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  785. '
  786. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  787. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  788. '
  789. '    Purpose/Description In brief:
  790. '    Sub to get and set information on the current user.
  791. '    TMS DLL routine.
  792. '
  793. '=========================================================
  794.  
  795. ' Set up general error handler
  796.  
  797. On Error GoTo Error_DoRegInfo:
  798.  
  799.     ' ========== Code Starts.==========
  800.  
  801.  
  802.     Dim tUserInfo As VBUSERINFO
  803.  
  804.     tUserInfo.nSize = Len(tUserInfo)
  805.  
  806.     ' Call TMS DLL routine.
  807.     If bAboutCall(ID_USER, tUserInfo) <> False Then
  808.  
  809.         ' Set information into frm.
  810.         frm!lblName.Caption = tUserInfo.sName
  811.         frm!lblCompany.Caption = tUserInfo.sOrg
  812.         
  813.     Else
  814.         If nProcessDLLError() = True Then End
  815.     End If
  816.  
  817.  
  818.     ' ========== Code Ends  .==========
  819.  
  820.     Exit Sub
  821.  
  822. ' Error handler
  823. Error_DoRegInfo:
  824.  
  825.     ' Call general error handler
  826.  
  827.     ErrorHandler "ABOUTBOX.BAS/DoRegInfo", Err, Error$
  828.  
  829.     ' Default resume behaviour: exit this sub/func
  830.  
  831.     Resume Exit_DoRegInfo:
  832.  
  833. Exit_DoRegInfo:
  834.  
  835.  
  836. End Sub
  837.  
  838. '==========================================================
  839. '
  840. '    Function - DoSysResources
  841. '
  842. '    Author - Peter J. Morris. TMS Ltd.
  843. '
  844. '    Date Written: #### Date - 16/11/94    Time - 03:11
  845. '
  846. '    Purpose - See function purpose.
  847. '
  848. '    Revisions:
  849. '    BY            WHY            AFFECTED
  850. '    Peter J. Morris. TMS Ltd. Original code.
  851. '
  852. '
  853. '    INPUTS -  frm -> Form to use.
  854. '
  855. '
  856. '    OUTPUTS - None
  857. '
  858. '==========================================================
  859. Sub DoSysResources (frm As Form)
  860. '==========================================================
  861. '
  862. '    Form: ABOUTBOX.BAS Procedure: DoSysResources
  863. '
  864. '    Author - Peter J. Morris. TMS Ltd.
  865. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  866. '
  867. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  868. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  869. '
  870. '    Purpose/Description In brief:
  871. '    Sub to do system resource heap stuff.
  872. '
  873. '=========================================================
  874.  
  875. ' Set up general error handler
  876.  
  877. On Error GoTo Error_DoSysResources:
  878.  
  879.     ' ========== Code Starts.==========
  880.  
  881.  
  882.     ' Defined by TOOLHELP.DLL.
  883.     Dim shi As SYSHEAPINFO
  884.  
  885.     ' init structure.
  886.     shi.lSize = Len(shi)
  887.  
  888.     ' Call TOOLHELP API.
  889.     g_vDummy = SystemHeapInfo(shi)
  890.  
  891.     ' Update captions.
  892.     frm!lblUserFree = Format$(shi.nUserFreePercent, "##") & "%"
  893.     frm!lblGDIFree = Format$(shi.nGDIFreePercent, "##") & "%"
  894.  
  895.  
  896.     ' ========== Code Ends  .==========
  897.  
  898.     Exit Sub
  899.  
  900. ' Error handler
  901. Error_DoSysResources:
  902.  
  903.     ' Call general error handler
  904.  
  905.     ErrorHandler "ABOUTBOX.BAS/DoSysResources", Err, Error$
  906.  
  907.     ' Default resume behaviour: exit this sub/func
  908.  
  909.     Resume Exit_DoSysResources:
  910.  
  911. Exit_DoSysResources:
  912.  
  913.  
  914. End Sub
  915.  
  916. '==========================================================
  917. '
  918. '    Function - DoVersions
  919. '
  920. '    Author - Peter J. Morris. TMS Ltd.
  921. '
  922. '    Date Written: #### Date - 16/11/94    Time - 03:11
  923. '
  924. '    Purpose - See function purpose.
  925. '
  926. '    Revisions:
  927. '    BY            WHY            AFFECTED
  928. '    Peter J. Morris. TMS Ltd. Original code.
  929. '
  930. '
  931. '    INPUTS -  frm -> Form to use.
  932. '
  933. '
  934. '    OUTPUTS - None
  935. '
  936. '==========================================================
  937. Sub DoVersions (frm As Form)
  938. '==========================================================
  939. '
  940. '    Form: ABOUTBOX.BAS Procedure: DoVersions
  941. '
  942. '    Author - Peter J. Morris. TMS Ltd.
  943. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  944. '
  945. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  946. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  947. '
  948. '    Purpose/Description In brief:
  949. '    Sub to do Windows and DOS version stuff.
  950. '
  951. '=========================================================
  952.  
  953. ' Set up general error handler
  954.  
  955. On Error GoTo Error_DoVersions:
  956.  
  957.     ' ========== Code Starts.==========
  958.  
  959.  
  960.     Dim vi As VBVERINFO
  961.     
  962.     vi.nSize = Len(vi)
  963.     
  964.     If bAboutCall(ID_VERSION, vi) <> False Then
  965.     
  966.         ' Visual Basic version. Note that this doesn't work too well anymore
  967.         ' under VB4.
  968.         frm!lblVBVersion.Caption = Format$(Hex$(vi.nVBVer), "0\.00")
  969.  
  970.         ' DOS version.
  971.         frm!lblDOSVer.Caption = CStr(vi.nDOSMax) & "." & Format$(vi.nDOSMin, "00")
  972.         
  973.         ' Windows version.
  974.         frm!lblWINVer.Caption = vi.sWinVer
  975.         
  976.     Else
  977.         If nProcessDLLError() = True Then End
  978.     End If
  979.  
  980.  
  981.     ' ========== Code Ends  .==========
  982.  
  983.     Exit Sub
  984.  
  985. ' Error handler
  986. Error_DoVersions:
  987.  
  988.     ' Call general error handler
  989.  
  990.     ErrorHandler "ABOUTBOX.BAS/DoVersions", Err, Error$
  991.  
  992.     ' Default resume behaviour: exit this sub/func
  993.  
  994.     Resume Exit_DoVersions:
  995.  
  996. Exit_DoVersions:
  997.  
  998.  
  999. End Sub
  1000.  
  1001. Sub DoWinFlags (frm As Form)
  1002. '==========================================================
  1003. '
  1004. '    Form: ABOUTBOX.BAS Procedure: DoWinFlags
  1005. '
  1006. '    Author - Peter J. Morris. TMS Ltd.
  1007. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  1008. '
  1009. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  1010. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  1011. '
  1012. '    Purpose/Description In brief:
  1013. '    Sub do do the GetWinFlags() stuff.
  1014. '
  1015. '=========================================================
  1016.  
  1017. ' Set up general error handler
  1018.  
  1019. On Error GoTo Error_DoWinFlags:
  1020.  
  1021.     ' ========== Code Starts.==========
  1022.  
  1023.  
  1024.     Dim sTemp       As String
  1025.     Dim lResult     As Long
  1026.  
  1027.     ' Retrieve the flags.
  1028.     lResult = GetWinFlags()
  1029.  
  1030.     ' Get processor mode.
  1031.     frm!lblProtectMode.Caption = Format$((lResult And WF_PMODE) = WF_PMODE, g_sYesNo)
  1032.     
  1033.     ' Get processor type.
  1034.     If (lResult And WF_CPU086) = WF_CPU086 Then
  1035.         sTemp = "8086"
  1036.     ElseIf (lResult And WF_CPU186) = WF_CPU186 Then
  1037.         sTemp = "80186"
  1038.     ElseIf (lResult And WF_CPU286) = WF_CPU286 Then
  1039.         sTemp = "80286"
  1040.     ElseIf (lResult And WF_CPU386) = WF_CPU386 Then
  1041.         sTemp = "80386"
  1042.     ElseIf (lResult And WF_CPU486) = WF_CPU486 Then
  1043.         sTemp = "80486 or Pentium"
  1044.     End If
  1045.  
  1046.     frm!lblProcessor.Caption = sTemp
  1047.  
  1048.     ' Get Windows' mode.
  1049.     If (lResult And WF_STANDARD) = WF_STANDARD Then
  1050.         sTemp = "Standard Mode"
  1051.     ElseIf (lResult And WF_ENHANCED) = WF_ENHANCED Then
  1052.         sTemp = "Enhanced Mode"
  1053.     End If
  1054.  
  1055.     frm!lblMode.Caption = sTemp
  1056.  
  1057.     ' Get EMS type.
  1058.     If (lResult And WF_LARGEFRAME) = WF_LARGEFRAME Then
  1059.         sTemp = "Large Frame EMS"
  1060.     ElseIf (lResult And WF_SMALLFRAME) = WF_SMALLFRAME Then
  1061.         sTemp = "Small Frame EMS"
  1062.     Else
  1063.         sTemp = "No EMS Support"
  1064.     End If
  1065.  
  1066.     frm!lblEMS.Caption = sTemp
  1067.     
  1068.     ' Get coprocessor status.
  1069.     frm!lblCoProcessor.Caption = Format$((lResult And WF_8087) = WF_8087, g_sYesNo)
  1070.         
  1071.     ' Get paging state.
  1072.     frm!lblPaging.Caption = Format$((lResult And WF_PAGING) = WF_PAGING, g_sYesNo)
  1073.  
  1074.  
  1075.     ' ========== Code Ends  .==========
  1076.  
  1077.     Exit Sub
  1078.  
  1079. ' Error handler
  1080. Error_DoWinFlags:
  1081.  
  1082.     ' Call general error handler
  1083.  
  1084.     ErrorHandler "ABOUTBOX.BAS/DoWinFlags", Err, Error$
  1085.  
  1086.     ' Default resume behaviour: exit this sub/func
  1087.  
  1088.     Resume Exit_DoWinFlags:
  1089.  
  1090. Exit_DoWinFlags:
  1091.  
  1092.  
  1093. End Sub
  1094.  
  1095. '==========================================================
  1096. '
  1097. '    Function - Init
  1098. '
  1099. '    Author - Peter J. Morris. TMS Ltd.
  1100. '
  1101. '    Date Written: #### Date - 16/11/94    Time - 03:11
  1102. '
  1103. '    Purpose - See function purpose.
  1104. '
  1105. '    Revisions:
  1106. '    BY            WHY            AFFECTED
  1107. '    Peter J. Morris. TMS Ltd. Original code.
  1108. '
  1109. '
  1110. '    INPUTS -  None
  1111. '
  1112. '
  1113. '    OUTPUTS - None
  1114. '
  1115. '==========================================================
  1116. Sub Init ()
  1117. '==========================================================
  1118. '
  1119. '    Form: ABOUTBOX.BAS Procedure: Init
  1120. '
  1121. '    Author - Peter J. Morris. TMS Ltd.
  1122. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  1123. '
  1124. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  1125. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  1126. '
  1127. '    Purpose/Description In brief:
  1128. '    Sets global variables with registration information.
  1129. '
  1130. '=========================================================
  1131.  
  1132. ' Set up general error handler
  1133.  
  1134. On Error GoTo Error_Init:
  1135.  
  1136.     ' ========== Code Starts.==========
  1137.  
  1138.  
  1139.     g_sAppName = "TMS Cool-App" 'LoadResString(g_nAppName)
  1140.     g_sVersion = "Version 1.30a" 'LoadResString(g_nVersion)
  1141.     g_sCopyright = "Copyright⌐ 1994-1995 The Mandelbrot Set (Int'l) Ltd." 'LoadResString(g_nCopyright)
  1142.     g_sProductID = "1234-5678-91011" 'LoadResString(g_nProductID)
  1143.     
  1144.  
  1145.  
  1146.     ' ========== Code Ends  .==========
  1147.  
  1148.     Exit Sub
  1149.  
  1150. ' Error handler
  1151. Error_Init:
  1152.  
  1153.     ' Call general error handler
  1154.  
  1155.     ErrorHandler "ABOUTBOX.BAS/Init", Err, Error$
  1156.  
  1157.     ' Default resume behaviour: exit this sub/func
  1158.  
  1159.     Resume Exit_Init:
  1160.  
  1161. Exit_Init:
  1162.  
  1163.  
  1164. End Sub
  1165.  
  1166. '==========================================================
  1167. '
  1168. '    Function - nProcessDLLError
  1169. '
  1170. '    Author - Peter J. Morris. TMS Ltd.
  1171. '
  1172. '    Date Written: #### Date - 16/11/94    Time - 03:11
  1173. '
  1174. '    Purpose - See function purpose.
  1175. '
  1176. '    Revisions:
  1177. '    BY            WHY            AFFECTED
  1178. '    Peter J. Morris. TMS Ltd. Original code.
  1179. '
  1180. '
  1181. '    INPUTS -  None
  1182. '
  1183. '
  1184. '    OUTPUTS - None
  1185. '
  1186. '==========================================================
  1187. Function nProcessDLLError () As Integer
  1188. '==========================================================
  1189. '
  1190. '    Form: ABOUTBOX.BAS Procedure: nProcessDLLError
  1191. '
  1192. '    Author - Peter J. Morris. TMS Ltd.
  1193. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  1194. '
  1195. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  1196. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  1197. '
  1198. '    Purpose/Description In brief:
  1199. '    Handle errors calling into TMS DLL (if any).
  1200. '
  1201. '=========================================================
  1202.  
  1203. ' Set up general error handler
  1204.  
  1205. On Error GoTo Error_nProcessDLLError:
  1206.  
  1207.     ' ========== Code Starts.==========
  1208.  
  1209.  
  1210.     nProcessDLLError = MsgBox("An error occurred during a call into the TMS DLL. " & "Treat error as critical?", MB_YESNO + MB_ICONQUESTION, "Error calling DLL") = IDYES
  1211.  
  1212.  
  1213.     ' ========== Code Ends  .==========
  1214.  
  1215.     Exit Function
  1216.  
  1217. ' Error handler
  1218. Error_nProcessDLLError:
  1219.  
  1220.     ' Call general error handler
  1221.  
  1222.     ErrorHandler "ABOUTBOX.BAS/nProcessDLLError", Err, Error$
  1223.  
  1224.     ' Default resume behaviour: exit this sub/func
  1225.  
  1226.     Resume Exit_nProcessDLLError:
  1227.  
  1228. Exit_nProcessDLLError:
  1229.  
  1230.  
  1231. End Function
  1232.  
  1233. '==========================================================
  1234. '
  1235. '    Function - sCheckCaption
  1236. '
  1237. '    Author - Peter J. Morris. TMS Ltd.
  1238. '
  1239. '    Date Written: #### Date - 16/11/94    Time - 03:11
  1240. '
  1241. '    Purpose - See function purpose.
  1242. '
  1243. '    Revisions:
  1244. '    BY            WHY            AFFECTED
  1245. '    Peter J. Morris. TMS Ltd. Original code.
  1246. '
  1247. '
  1248. '    INPUTS -  frm   -> Form to use.
  1249. '              cp    -> Control to test.
  1250. '              sText -> Text to fit.
  1251. '
  1252. '
  1253. '    OUTPUTS - None
  1254. '
  1255. '==========================================================
  1256. Function sCheckCaption (frm As Form, cp As Control, ByVal sText As String) As String
  1257. '==========================================================
  1258. '
  1259. '    Form: ABOUTBOX.BAS Procedure: sCheckCaption
  1260. '
  1261. '    Author - Peter J. Morris. TMS Ltd.
  1262. '    Template fitted: #### Date - 16/11/94    Time - 03:11
  1263. '
  1264. '    Copyright and status if any: Copyright ⌐ TMS 1994,1995
  1265. '    All rights reserved. Status @BLUE@TMS.DEMO@COLD
  1266. '
  1267. '    Purpose/Description In brief:
  1268. '    Sub to adjust caption text (paths in this case) so that
  1269. '    they fit into labels.
  1270. '
  1271. '=========================================================
  1272.  
  1273. ' Set up general error handler
  1274.  
  1275. On Error GoTo Error_sCheckCaption:
  1276.  
  1277.     ' ========== Code Starts.==========
  1278.  
  1279.  
  1280.     Dim nOldMode As Integer
  1281.     
  1282.     ' Save forms old scalemode.
  1283.     nOldMode = frm.ScaleMode
  1284.     
  1285.     ' Set scale mode to pels for speed if nothing else. Note that to be more bullet
  1286.     ' proof that we shoudl update the form's font etc so that it matches.
  1287.     frm.ScaleMode = PIXELS
  1288.     
  1289.     ' Check to see if current caption text overflows the label. If it does then...
  1290.     If cp.Left + frm.TextWidth(sText) > frm.ScaleWidth Then
  1291.         
  1292.             Dim nLoop As Integer
  1293.             
  1294.             ' Step backwards through the string looking for a '\' character,
  1295.             For nLoop = Len(sText) To 1 Step -1
  1296.                 If Mid$(sText, nLoop, 1) = "\" Then
  1297.                     ' Found the first (starting from the end) '\'. Assume that the drive letter and
  1298.                     ' the last dir name together fits. Obviously this would need checking when using
  1299.                     ' long file names for example.
  1300.                     sText = Left$(sText, 2) & "\...\" & Mid$(sText, nLoop + 1)
  1301.                     ' Jump out of the for loop.
  1302.                     Exit For
  1303.                 End If
  1304.             Next
  1305.     
  1306.     End If
  1307.     
  1308.     ' Reset the form's scalemode.
  1309.     frm.ScaleMode = nOldMode
  1310.  
  1311.     ' Return the new text.
  1312.     sCheckCaption = sText
  1313.  
  1314.  
  1315.  
  1316.     ' ========== Code Ends  .==========
  1317.  
  1318.     Exit Function
  1319.  
  1320. ' Error handler
  1321. Error_sCheckCaption:
  1322.  
  1323.     ' Call general error handler
  1324.  
  1325.     ErrorHandler "ABOUTBOX.BAS/sCheckCaption", Err, Error$
  1326.  
  1327.     ' Default resume behaviour: exit this sub/func
  1328.  
  1329.     Resume Exit_sCheckCaption:
  1330.  
  1331. Exit_sCheckCaption:
  1332.  
  1333.  
  1334. End Function
  1335.  
  1336.